perm filename CLIP.F4[TMP,LCS] blob
sn#469486 filedate 1979-08-22 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C THIS IS A SUBROUTINE TO XM3.FAI
C00018 ENDMK
Cā;
C THIS IS A SUBROUTINE TO XM3.FAI
SUBROUTINE CLIP(J,K,L,IRT,LEFT,ITOP,IBOT)
COMMON /CLIPXY/JJ,KK,JX,KX
C ZERO ABOVE IN FAIL PROG.
C ASSUMES N IS INITIALIZED =0
IF(L.GT.0)GO TO 2
IBOT=-K
RETURN
2 JZ=J
KZ=K
C SAVE THESE FOR LATER
IF(L.NE.3)GO TO 1
N=0
C DOESN'T WORK FOR JUMP OUT WITH INSVIS VECT. MUST KNOW NEXT POINT
C TO SET PROPER ANGLE.
IF(J.LT.LEFT)GO TO 40
IF(J.GT.IRT)GO TO 41
44 IF(K.LT.IBOT)GO TO 42
IF(K.GT.ITOP)GO TO 43
C NOW INBOUNDS
GO TO 4
40 J=LEFT
N=-1
GO TO 44
41 J=IRT
N=-1
GO TO 44
42 K=IBOT
GO TO 45
43 K=ITOP
GO TO 45
1 IF(N.EQ.0)GO TO 11
C JUMP IF LAST POINT WAS IN BOUNDS
IF(JJ.LE.IRT.AND.JJ.GE.LEFT)GO TO 6
C NOW JJ IS OUT OF BOUNDS, CLIP IT
5 IF(IBOTH(J,JJ,LEFT,IRT).EQ.0)GO TO 4
C GO BACK IF ENTIRE SEGMENT IS OUT OF BOUNDS
CALL CLP(JJ,KK,J,K,JJ,KK,LEFT,IRT)
C CLIP FROM INVIS VECT WHICH IS OUT OF BOUNDS
IF(KK.LE.ITOP.AND.KK.GE.IBOT)GO TO 10
C CLIP MORE IF OTHER POINT IS ALSO OUT.
6 IF(IBOTH(K,KK,IBOT,ITOP).EQ.0)GO TO 4
CALL CLP(KK,JJ,K,J,KK,JJ,IBOT,ITOP)
CC10 CALL AIVECT(JJ,KK)
10 N=0
11 IF(J.GT.IRT.OR.J.LT.LEFT)GO TO 7
IF(K.GT.ITOP.OR.K.LT.IBOT)GO TO 7
CC9 CALL AVECT(J,K)
4 JJ=JZ
KK=KZ
C REMEMBER THE COORDS.
RETURN
7 CALL CLP(JX,KX,JJ,KK,J,K,LEFT,IRT)
IF(KX.LE.ITOP.AND.KX.GE.IBOT)GO TO 12
CALL CLP(KX,JX,KK,JJ,KX,JX,IBOT,ITOP)
12 J=JX
K=KX
JZ=J
KZ=K
CC12 CALL AVECT(JX,KX)
45 N=-1
GO TO 4
8 CALL CLP(KX,JX,KK,JJ,K,J,IBOT,ITOP)
GO TO 12
END
FUNCTION IBOTH(J,JJ,N1,N2)
IBOTH=0
IF(JJ.GE.N2.AND.J.GT.N2)RETURN
IF(JJ.LE.N1.AND.J.LT.N1)RETURN
IBOTH=-1
END
SUBROUTINE CLP(JX,KX,JJ,KK,J,K,N1,N2)
C JJ,KK=OLD POINT J,K=NEW POINT JX,KX=CLIPPED
JX=N2
IF(J.LT.N1)JX=N1
IF(KK.NE.K)GO TO 1
KX=KK
RETURN
1 KX=KK+(K-KK)*(JX-JJ)/(J-JJ)
END